' Crystal Vision By Jeff White
' Placed In The Public Domain By Merlin's Software
' Subroutine To Load Graphics By Carolyn Scheppner
CLEAR 32000,45000
Main:
DIM bPlane&(5), cTabWork%(32), cTabSave%(32),p(60)
DECLARE FUNCTION xOpen&  LIBRARY
DECLARE FUNCTION xRead&  LIBRARY
DECLARE FUNCTION xWrite& LIBRARY
DECLARE FUNCTION IoErr&  LIBRARY
DECLARE FUNCTION AllocMem&() LIBRARY
DIM g(40,40),h(40,40),i(40,40),j(20,20),k(20,20),l(20,20),m(20,20),n(20,20)
LIBRARY "dos.library"
LIBRARY "exec.library"
LIBRARY "graphics.library"
FOR m = 0 TO 8: READ MM%(m): NEXT m
DATA 85,0,160,1,15500,64,0,0,0
SAY TRANSLATE$("ONE MOMENT PLEASE."),MM%
title:
acbmname$ = "crystal.pic" 
loadError$ = ""
GOSUB LoadACBM
IF loadError$ <> "" THEN GOTO Mcleanup
Mcleanup:
GOTO ROUTINE
Mcleanup2:
LIBRARY CLOSE
IF loadError$ <> "" THEN PRINT loadError$
END
LoadACBM:
f$ = acbmname$
fHandle& = 0
mybuf& = 0
foundBMHD = 0
foundCMAP = 0
foundCAMG = 0
foundCCRT = 0
foundABIT = 0
filename$ = f$ + CHR$(0)
fHandle& = xOpen&(SADD(filename$),1005)
IF fHandle& = 0 THEN
   loadError$ = "Can't open/find pic file"
   GOTO Lcleanup
END IF
ClearPublic& = 65537
mybufsize& = 360
mybuf& = AllocMem&(mybufsize&,ClearPublic&)
IF mybuf& = 0 THEN
   loadError$ = "Can't alloc buffer"
   GOTO Lcleanup
END IF
inbuf& = mybuf&
cbuf& = mybuf& + 120
ctab& = mybuf& + 240
rLen& = xRead&(fHandle&,inbuf&,12)
tt$ = ""
FOR kk = 8 TO 11
   tt% = PEEK(inbuf& + kk)
   tt$ = tt$ + CHR$(tt%)
NEXT
IF tt$ <> "ACBM" THEN 
   loadError$ = "Not an ACBM pic file"
   GOTO Lcleanup
END IF
ChunkLoop:
REM - Get Chunk name/length
 rLen& = xRead&(fHandle&,inbuf&,8)
 icLen& = PEEKL(inbuf& + 4)
 tt$ = ""
 FOR kk = 0 TO 3
    tt% = PEEK(inbuf& + kk)
    tt$ = tt$ + CHR$(tt%)
 NEXT   
IF tt$ = "BMHD" THEN  'BitMap header 
   foundBMHD = 1
   rLen& = xRead&(fHandle&,inbuf&,icLen&)
   iWidth%  = PEEKW(inbuf&)
   iHeight% = PEEKW(inbuf& + 2)
   iDepth%  = PEEK(inbuf& + 8)  
   iCompr%  = PEEK(inbuf& + 10)
   scrWidth%  = PEEKW(inbuf& + 16)
   scrHeight% = PEEKW(inbuf& + 18)
   iRowBytes% = iWidth% /8
   scrRowBytes% = scrWidth% / 8
   nColors%  = 2^(iDepth%)
   AvailRam& = FRE(-1)
   NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000
   IF AvailRam& < NeededRam& THEN
      loadError$ = "Not enough free ram."
      GOTO Lcleanup
   END IF
   kk = 1
   IF scrWidth% > 320 THEN kk = kk + 1
   IF scrHeight% > 200  THEN kk = kk + 2
   SCREEN 2,scrWidth%,scrHeight%,iDepth%,kk
  WINDOW 2,"Crystal Vision",,15,2
  SCREEN 3,scrWidth%,scrHeight%,iDepth%,kk
   REM - Get addresses of structures
   GOSUB GetScrAddrs
   REM - Black out screen
   CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
ELSEIF tt$ = "CMAP" THEN  'ColorMap
   foundCMAP = 1
   rLen& = xRead&(fHandle&,cbuf&,icLen&)
   REM - Build Color Table
   FOR kk = 0 TO nColors% - 1
      red% = PEEK(cbuf&+(kk*3))
      gre% = PEEK(cbuf&+(kk*3)+1)
      blu% = PEEK(cbuf&+(kk*3)+2)
      regTemp% = (red%*16)+(gre%)+(blu%/16)
      POKEW(ctab&+(2*kk)),regTemp%
   NEXT
ELSEIF tt$ = "CAMG" THEN 'Amiga ViewPort Modes
   foundCAMG = 1
   rLen& = xRead&(fHandle&,inbuf&,icLen&)
   camgModes& = PEEKL(inbuf&)
ELSEIF tt$ = "CCRT" THEN 'Graphicraft color cycle info
   foundCCRT = 1
   rLen& = xRead&(fHandle&,inbuf&,icLen&)
   ccrtDir%    = PEEKW(inbuf&)
   ccrtStart%  = PEEK(inbuf& + 2)
   ccrtEnd%    = PEEK(inbuf& + 3)
   ccrtSecs&   = PEEKL(inbuf& + 4)
   ccrtMics&   = PEEKL(inbuf& + 8)
ELSEIF tt$ = "ABIT" THEN  'Contiguous BitMap 
   foundABIT = 1
   plSize& = (scrWidth%/8) * scrHeight%
   FOR pp = 0 TO iDepth% -1
      rLen& = xRead&(fHandle&,bPlane&(pp),plSize&)   
   NEXT
ELSE 
   REM - Reading unknown chunk  
   FOR kk = 1 TO icLen&
      rLen& = xRead&(fHandle&,inbuf&,1)
   NEXT
   REM - If odd length, read 1 more byte
   IF (icLen& OR 1) = icLen& THEN 
      rLen& = xRead&(fHandle&,inbuf&,1)
   END IF
END IF
IF foundBMHD AND foundCMAP AND foundABIT THEN
   GOTO GoodLoad
END IF
IF rLen& > 0 THEN GOTO ChunkLoop
IF rLen& < 0 THEN  'Read error
   loadError$ = "Read error"
   GOTO Lcleanup
END IF   
IF (foundBMHD=0) OR (foundABIT=0) OR (foundCMAP=0) THEN
   loadError$ = "Needed ILBM chunks not found"
   GOTO Lcleanup
END IF
GoodLoad:
loadError$ =""
IF foundCMAP THEN 
   CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
END IF
Lcleanup:
IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
RETURN
GetScrAddrs:
REM - Get addresses of screen structures
   sWindow&   = WINDOW(7)
   sScreen&   = PEEKL(sWindow& + 46)
   sViewPort& = sScreen& + 44
   sRastPort& = sScreen& + 84
   sColorMap& = PEEKL(sViewPort& + 4)
   colorTab&  = PEEKL(sColorMap& + 4)
   sBitMap&   = PEEKL(sRastPort& + 4)
   scrWidth%  = PEEKW(sScreen& + 12)
   scrHeight% = PEEKW(sScreen& + 14)
   scrDepth%  = PEEK(sBitMap& + 5)
   nColors%   = 2^scrDepth%
   FOR kk = 0 TO scrDepth% - 1
      bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
   NEXT
RETURN

ROUTINE:
WINDOW OUTPUT 2
GET (130,59)-(188,127),g
GET (29,59)-(87,127),h
GET (226,59)-(284,127),i
GET (28,5)-(69,53),j
GET (225,5)-(266,53),k
GET (28,131)-(61,173),l
GET (214,131)-(247,173),m
GET (252,131)-(285,173),n
LINE (27,5)-(70,54),12,bf
LINE (223,5)-(266,54),12,bf
LINE (28,131)-(61,173),12,bf
LINE (214,131)-(285,173),12,bf
LINE (27,56)-(90,130),12,bf
LINE (224,56)-(286,130),12,bf
LINE (130,59)-(188,127),29,bf
SCREEN CLOSE 3
GOSUB appear3
SAY TRANSLATE$("are you ready to select a card."),MM%
GOSUB SWITCH
SAY TRANSLATE$("MASTER. HAVE A SPECTAYTOR SELECT A CARD. ANY CARD."),MM%
SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
GOSUB SWITCH
SAY TRANSLATE$("CONSINTRATE ON YOUR CARD."),MM%
GOSUB appear
SAY TRANSLATE$("WOULD YOU LIKE TO TRY AGAIN."),MM%
GOSUB SWITCH
IF MOUSE(4) >90 THEN GOTO FINISHED
SAY TRANSLATE$("MASTER. HAVE A SPECTAYTOR SELECT A CARD."),MM%
SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
GOSUB SWITCH
GOSUB appear1
SAY TRANSLATE$("CARE TO TEST ME ONCE MORE"),MM%
GOSUB SWITCH
IF MOUSE(4) >90 THEN GOTO FINISHED
SAY TRANSLATE$("MASTER. ONE MORE TIME FOR THE NON BELEAVERS."),MM%
SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
GOSUB SWITCH
GOSUB appear2
FINISHED:
PUT (138,65),k,PSET
SAY TRANSLATE$("I HOPE YOU HAVE ENJOYED THIS DEMONSTRATION."),MM%
PUT (138,65),j,PSET
SAY TRANSLATE$(" "),MM%
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("GOOD BY UNTIL WE MEET AGAIN."),MM%
PUT (138,65),j,PSET
y= 65
FOR T= 1 TO 50
LINE (138,y)-(180,y),29,bf
y= y+1
FOR x= 1 TO 100: NEXT
NEXT
y= 65
FOR T= 1 TO 50
LINE (138,y)-(180,y),29,bf
y= y+1
FOR x= 1 TO 100: NEXT
NEXT
SYSTEM
appear:
FOR T= 1 TO 6000: NEXT
SAY TRANSLATE$(" think harder. i can not get an image."),MM%
FOR T= 1 TO 6000: NEXT
SAY TRANSLATE$(" i have it now. your card was the king of harts."),MM%
a= 0.63
PALETTE 1,a,a,a
PUT(130,59),g,PSET
FOR T= 1 TO 62
a= a+ 0.005
PALETTE 1,a,a,a
NEXT
FOR T= 1 TO 5000: NEXT
FOR T= 1 TO 62
a= a- 0.005
PALETTE 1,a,a,a
NEXT
LINE (130,59)-(188,127),29,bf
RETURN
appear1:
SAY TRANSLATE$("CONSINTRATE ON YOUR CARD."),MM%
FOR T= 1 TO 3000: NEXT
SAY TRANSLATE$("THAT WAS EASY. YOUR CARD WAS THE 8 OF SPAYIDS."),MM%
FOR T= 1 TO 3000: NEXT
a= 0.63
PALETTE 1,a,a,a
PUT(130,59),h,PSET
FOR T= 1 TO 62
a= a+ 0.005
PALETTE 1,a,a,a
NEXT
FOR T= 1 TO 5000: NEXT
FOR T= 1 TO 62
a= a- 0.005
PALETTE 1,a,a,a
NEXT
LINE (130,59)-(188,127),29,bf
RETURN
appear2:
SAY TRANSLATE$("CONSINTRATE ."),MM%
FOR T= 1 TO 5000: NEXT
SAY TRANSLATE$("SO YOU THINK YOU CAN FOOL ZARDOZ."),MM%
FOR T= 1 TO 3000: NEXT
SAY TRANSLATE$("YOUR CARD WAS THE 3 OF DYEMONDS."),MM%
a= 0.63
PALETTE 1,a,a,a
PUT(130,59),i,PSET
FOR T= 1 TO 62
a= a+ 0.005
PALETTE 1,a,a,a
NEXT
FOR T= 1 TO 5000: NEXT
FOR T= 1 TO 62
a= a- 0.005
PALETTE 1,a,a,a
NEXT
LINE (130,59)-(188,127),29,bf
RETURN
appear3:
PUT (138,65),k,PSET
SAY TRANSLATE$("MERLINS SOFTWARE PRESENTS."),MM%
PUT (138,65),j,PSET
SAY TRANSLATE$(" "),MM%
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("crystal vision."),MM%
PUT (138,65),j,PSET
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("my name"),MM%
PUT (138,65),j,PSET
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("is zardoz."),MM%
PUT (138,65),j,PSET
SAY TRANSLATE$(" "),MM%
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("I will now demonstrate my powers of telepathy."),MM%
PUT (138,65),j,PSET
SAY TRANSLATE$(" "),MM%
FOR T= 1 TO 1000: NEXT
PUT (138,65),k,PSET
SAY TRANSLATE$("lets BEGIN."),MM%
PUT (138,65),j,PSET
y= 65
FOR T= 1 TO 50
LINE (138,y)-(180,y),29,bf
y= y+1
FOR x= 1 TO 100: NEXT
NEXT
RETURN
SWITCH:
a= 0.63
PALETTE 1,a,a,a
PUT(142,68),l,PSET
FOR T= 1 TO 62
a= a+ 0.005
PALETTE 1,a,a,a
NEXT
CHOOSE:
IF MOUSE(0) <> 1 THEN CHOOSE
IF MOUSE(4) <78 THEN GOTO yes
IF MOUSE(4) >90 THEN GOTO no
GOTO CHOOSE
yes:
PUT (142,68),n,PSET
FOR T= 1 TO 3000: NEXT
FOR T= 1 TO 62
a= a- 0.005
PALETTE 1,a,a,a
NEXT
LINE (142,68)-(190,120),29,bf
RETURN
no:
PUT (142,68),m,PSET
FOR T= 1 TO 3000: NEXT
FOR T= 1 TO 62
a= a-0.005
PALETTE 1,a,a,a
NEXT
LINE (142,68)-(190,120),29,bf
RETURN